home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / paslib.zip / PASLIB01.INC < prev    next >
Text File  |  1986-05-22  |  31KB  |  801 lines
  1.  
  2.    (*
  3.    **     PASLIB01.INC
  4.    **          Pascal function library
  5.    **          by Robert B. Wooster, May, 1986
  6.    **
  7.    *)
  8.  
  9.    CONST
  10.       IsColor : Boolean = False; {7/4/85}
  11.       MaxRow = 25;
  12.       MaxCol = 80;
  13.       { screen attributes }
  14.       LO_V : Byte = 7; HI_V : Byte = 15; RE_V : Byte = 112;
  15.       { cursor control keys }
  16.       SK_HM = 71; SK_UP = 72; SK_PU = 73; SK_LE = 75; SK_RI = 77;
  17.       SK_EN = 79; SK_DO = 80; SK_PD = 81; SK_IN = 82; SK_DE = 83;
  18.       E_S_C = 27;             {6/22/85}
  19.       { function keys }
  20.       SK_F1 = 59; SK_F2 = 60; SK_F3 = 61; SK_F4 = 62; SK_F5 = 63;
  21.       SK_F6 = 64; SK_F7 = 65; SK_F8 = 66; SK_F9 = 67; SK_F0 = 68;
  22.    TYPE
  23.       chrset = SET OF Char;
  24.       string80 = STRING[80];  {7/3/85}
  25.       bigstring = STRING[255];
  26.       regtype = RECORD CASE Integer OF
  27.          1 : (ax, bx, cx, dx, bp, si, ds, es, fl : Integer);
  28.          2 : (AL, AH, BL, BH, CL, CH, DL, DH : Byte);
  29.                 END;
  30.       datetype = RECORD
  31.                     month : 1..12; day : 1..31; year : 1960..2050;
  32.                  END;
  33.       timetype = RECORD
  34.                     hour, min, sec : Byte;
  35.                  END;
  36.       scrntype = ARRAY[0..1999] OF RECORD
  37.                                      Ch : Char; At : Byte;
  38.                                   END;
  39.       screenptr = ^scrntype;
  40.    VAR
  41.       EquipFlag : Integer ABSOLUTE $0000 : $0410; {7/4/85}
  42.       MonoScreen : scrntype ABSOLUTE $B000 : $0000;
  43.       ColorScreen : scrntype ABSOLUTE $B800 : $0000; {7/4/85}
  44.       KeyStat : Byte ABSOLUTE $0000 : $0417; {10/29/85}
  45.       savedscrn : screenptr;
  46.       SplKey : Byte;
  47.       sdt : datetype;
  48.       out : Text;             {6/22/85}
  49.       To_LST : Boolean;       {6/22/85}
  50.       EscFlag : Boolean;      {6/22/85}
  51.  
  52.       {---------------------------------------}
  53.       { monitor initialization                }
  54.       {---------------------------------------}
  55.    PROCEDURE InitMonitor;     {7/4/85}
  56.       BEGIN                   { initmonitor }
  57.          IsColor := (((Lo(EquipFlag) SHR 4) MOD 4) <> 3);
  58.       END;                    { initmonitor }
  59.  
  60.    PROCEDURE SwapMonitors;    {7/4/85}
  61.       VAR r : regtype;
  62.       BEGIN                   { swapmonitors }
  63.          IF (((Lo(EquipFlag) SHR 4) MOD 4) = 3) THEN BEGIN
  64.             EquipFlag := EquipFlag-16;
  65.             { note: color monitor set to 80x25 b&w }
  66.             r.AH := 0; r.AL := 2; Intr($10, r);
  67.          END                  {if}
  68.          ELSE BEGIN
  69.             EquipFlag := EquipFlag+16;
  70.             r.AH := 0; r.AL := 8; Intr($10, r);
  71.          END;                 {else}
  72.          InitMonitor;
  73.       END;                    { swapmonitors }
  74.       {==============================================}
  75.       {     i/o primitives                           }
  76.       {----------------------------------------------}
  77.    FUNCTION ugetc : Char;
  78.          { unbuffered getc, does not echo, ^c breaks }
  79.       VAR reg : regtype; c : Char;
  80.       BEGIN
  81.          SplKey := 0;
  82.          WITH reg DO BEGIN
  83.             ax := $0000; Intr($16, reg); c := Chr(AL);
  84.             SplKey := AH;
  85.          END;                 { with }
  86.          IF reg.AL = 3 THEN Halt; {^c}
  87.          IF reg.AL = 27 THEN BEGIN
  88.             SplKey := 27; {esc} c := Chr(0); {7/5/85}
  89.          END;
  90.          ugetc := c;
  91.       END;                    { ugetc }
  92.  
  93.    PROCEDURE putc(c : Char; b : Byte); {7/3/85}
  94.          { put character on screen with attribute b}
  95.       VAR row, col : Integer;
  96.       BEGIN
  97.          col := WhereX-1; row := WhereY-1;
  98.          IF IsColor THEN BEGIN
  99.             ColorScreen[80*row+col].Ch := c;
  100.             ColorScreen[80*row+col].At := b;
  101.          END                  {if}
  102.          ELSE BEGIN
  103.             MonoScreen[80*row+col].Ch := c;
  104.             MonoScreen[80*row+col].At := b;
  105.          END;                 {else}
  106.       END;                    { putc }
  107.  
  108.    PROCEDURE aputc(c : Char; a : Byte; col, row : Integer);
  109.          { put character c on screen at col,row with attribute a }
  110.       VAR i : Integer;
  111.       BEGIN
  112.          IF IsColor THEN BEGIN
  113.             ColorScreen[80*(row-1)+col-1].Ch := c;
  114.             ColorScreen[80*(row-1)+col-1].At := a;
  115.          END                  {if}
  116.          ELSE BEGIN
  117.             MonoScreen[80*(row-1)+col-1].Ch := c;
  118.             MonoScreen[80*(row-1)+col-1].At := a;
  119.          END;                 {else}
  120.       END; { putc }           {7/3/85}
  121.  
  122.       {==============================================}
  123.       {     i/o routines                             }
  124.       {----------------------------------------------}
  125.    FUNCTION GetUC(default : Char; okset : chrset) : Char;
  126.          { get a character from the keyboard, if lower case convert to upper }
  127.          { must be character in okset. if cr return default                  }
  128.       CONST CR = 13; ESC = 27;
  129.       VAR ok : Boolean; ch : Char;
  130.       BEGIN
  131.          REPEAT
  132.             Write(default, Char(8));
  133.             ch := UpCase(ugetc);
  134.             IF (ch = Chr(CR)) OR (ch = Chr(ESC)) OR (Ord(ch) = 0)
  135.             THEN ch := default;
  136.             ok := ch IN okset;
  137.             IF NOT ok THEN Write(Chr(7));
  138.          UNTIL ok;
  139.          Write(ch : 1);
  140.          GetUC := ch;
  141.       END;                    { getuc }
  142.  
  143.    PROCEDURE PutString(s : string80; col, row : Integer);
  144.          { put string on crt at indicated position }
  145.       BEGIN
  146.          GoToXY(col, row); Write(s);
  147.       END;                    { posstr }
  148.  
  149.    PROCEDURE GetString(VAR inpstr : string80;
  150.                        maxlen, col, row : Integer;
  151.                        default : string80);
  152.          { get an input string from the keyboard }
  153.       CONST BS = 8;           { ascii backspace }
  154.          CR = 13;             { ascii carriage return }
  155.          ESC = 27;            { ascii escape }
  156.  
  157.       VAR
  158.          ch : Char;
  159.          i : Integer;
  160.          isdefault : Boolean;
  161.          code : Byte;
  162.          done : Boolean;
  163.          FLDCHR : Char;       { input field marker }
  164.  
  165.  
  166.       FUNCTION AddChar(VAR s : string80; c : Char; max : Integer) : Boolean;
  167.             { add a character to the end of string }
  168.          BEGIN
  169.             IF Length(s) < max THEN BEGIN
  170.             s[0] := Succ(s[0]); s[Length(s)] := ch; END; { if }
  171.             IF Length(s) = max THEN AddChar := True
  172.             ELSE AddChar := False;
  173.          END;                 { addchar }
  174.  
  175.       PROCEDURE ChopChar(VAR s : string80);
  176.             { delete character from end of string }
  177.          BEGIN
  178.             IF Length(s) > 0 THEN s[0] := Pred(s[0]);
  179.             Write(^H); Write(FLDCHR); Write(^H);
  180.             IF (Length(s) = 0) AND isdefault THEN BEGIN
  181.                PutString(default, col, row);
  182.             GoToXY(col, row); END;
  183.          END;                 { chopchar }
  184.  
  185.       BEGIN
  186.          FLDCHR := Chr(254);
  187.          inpstr := '';
  188.          isdefault := Length(default) <> 0;
  189.          GoToXY(col, row);
  190.          FOR i := 1 TO maxlen DO Write(' ');
  191.          IF isdefault THEN PutString(default, col, row)
  192.          ELSE BEGIN GoToXY(col, row); {4/27/85}
  193.             FOR i := 1 TO maxlen DO Write(FLDCHR);
  194.          END;
  195.          GoToXY(col, row); done := False;
  196.          REPEAT
  197.             ch := ugetc;
  198.             CASE Ord(ch) OF
  199.                0 : done := True; { special key }
  200.                CR : done := True; { return }
  201.                BS : ChopChar(inpstr); { backspace }
  202.             ELSE BEGIN done := AddChar(inpstr, ch, maxlen);
  203.                IF isdefault AND (Length(inpstr) = 1) THEN BEGIN
  204.                   FOR i := 1 TO maxlen DO Write(FLDCHR); GoToXY(col, row);
  205.                END;
  206.             Write(ch); END;   { else }
  207.             END;              { case }
  208.          UNTIL done;
  209.          IF isdefault AND (Length(inpstr) = 0) THEN inpstr := default;
  210.          GoToXY(col, row); Write(' ' : maxlen);
  211.          GoToXY(col, row); Write(inpstr);
  212.       END;                    { getstring }
  213.  
  214.    PROCEDURE PutInteger(anum, col, row, maxlen : Integer); {11/8/85}
  215.          { put integer on crt}
  216.       VAR ts : String80;
  217.       BEGIN
  218.          Str(anum : maxl